#lang racket

(require racket/match)
(require (only-in srfi/1 every))

(require "utilities.scm")
(require "counter.scm")
(require "sets.scm")
(require "syntax-object.scm")
(require "scope-sets.scm")
(require "environment.scm")
(require "interpret.scm")

;;(require "debug.scm")

(provide resolve-program)

(define (resolve-program prg builtins)
  (resolve-program^ prg (create-env builtins)))

(define (resolve-program^ prg env)
  (if (null? prg)
      '()
      (let ((res (resolve-definition (car prg) env)))
	;; TODO: need to add the new definition
	(cons res (resolve-program^ (cdr prg) env)))))

(define (resolve-definition def env)
  ;; TODO: what if someone shadows DEFINE
  (let ((me-meta '((source . "resolve-definition"))))
    (match def

      ((list (syx 'id 'define meta-1) (syx 'id name meta-2) source)
       ;;
       ;; A simple definition (define <name> <single-form>)
       ;;
       ;; We make the definition as in scope before resolving it
       ;; this allows for recursive functions
       ;; TODO (update-env! env (make-dummy-binding name))
       (list (syx 'id 'define meta-1) (syx 'id name meta-2)
	     (resolve-exp source env)))

      ((list (syx 'id 'define meta-1) (list* header args) source)
       ;;
       ;; Handle implicit lambda definitions
       ;;
       ;; (define (f x y) y) ~> (define f (lambda (x y) y))
       ;;
       (resolve-definition
	(list (syx 'id 'define meta-1)
	      header
	      (list (syx 'id 'lambda me-meta) args source))
	env))

      ((list* (syx 'id 'define meta-1) header source source*)
       ;;
       ;; Handle implicit begin inside a definition
       ;;
       (resolve-definition
	(list (syx 'id 'define meta-1) header
	      (list* (syx 'id 'begin me-meta) source source*))
        env))
      
      ((list (syx 'id 'define-syntax meta-1) (syx 'id name meta-2) source)
       ;;
       ;; A syntax definition (define-syntax <name> <expander>)
       ;;
       (ss-bind! env name empty-set
                 `(macro . ,(lambda (exp env) (error "cannot use a macro before it's definition" (syx-id name)))))
       (let* ((expander (resolve-exp source env)))
         (ss-bind! env name empty-set
                   `(macro . ,(interpret-exp expander (ss-env-syntax-env env))))
         (syx 'atomic #t meta-1)))
      
      (else
       (error "resolve-definition: Bad definition!" def)))))

(define (resolve-exp exp env)
  (let ((exp (syn-force exp)))
    (cond ((syx-atomic? exp) exp)
	  ((syx-id? exp)
	   (match (ss-lookup (syx-id exp) (syx-scope-set exp) env)
	     (`(variable . ,x) x)
	     (else (error "resolve-exp: not a variable" exp))))
	  ((null? exp) exp)
	  ((pair? exp)
	   (let ((head (syn-force (car exp)))
		 (tail (syn-force (cdr exp))))
	     (if (syx-id? head)
		 ;; check if its a special form or macro
		 (match (ss-lookup (syx-id head) (syx-scope-set head) env)
		   (`(variable . ,x) (cons x (resolve-exp tail env)))
		   (`(special . ,s) (s exp env))
		   (`(macro . ,m)
		    (let ((sc ((ss-env-scope-counter env))))
		      (resolve-exp (m (syn-force (annotate exp (set (list sc)))) env) env)))
		   (else (error "resolve-exp: unknown thing")))
		 (cons (resolve-exp head env)
		       (resolve-exp tail env)))))
	  (else (error "resolve-exp:" exp)))))

;;; special form resolvers
;;

(define (implicit-begin exps)
  (if (null? (syn-cdr exps))
      (syn-car exps)
      (list* (syx 'id 'begin '()) exps)))

(define (special-lambda exp env)
  ;;
  ;; (lambda . ((<var> ...) . (<body> . ())))
  ;;    car       cadr          caddr   cdddr
  ;;                                    ^ <body-rest>
  (let* ((bindings (syn-car (syn-cdr exp)))
	 (body (implicit-begin (syn-cdr (syn-cdr exp))))
	 (sc ((ss-env-scope-counter env)))
	 (parameter-list (syn-map (lambda (var) (gensym+ss-bind! env sc var)) bindings)))
      (list (syx 'special 'lambda '())
	    parameter-list
	    (resolve-exp (annotate body (set (list sc))) env))))

(define (special-begin exp env)
  (let ((exps (syn-cdr exp)))
    (when (null? exps)
      (error "empty begin!"))
    (list* (syx 'special 'begin '())
           (syn-map (lambda (exp) (resolve-exp exp env)) exps))))

(define (special-if exp env)
  (let ((t (syn-car (syn-cdr exp)))
	(c (syn-car (syn-cdr (syn-cdr exp))))
	(a (syn-car (syn-cdr (syn-cdr (syn-cdr exp))))))
    (list (syx 'special 'if '())
	  (resolve-exp t env)
	  (resolve-exp c env)
	  (resolve-exp a env))))

(define (special-quote exp env)
  ;; TODO: error (or what?) if not atomic
  (let ((d (syn-car (syn-cdr exp))))
    (list (syx 'special 'quote '())
          (if (null? d)
              '()
              (syn->datum d)))))

(define (special-syntax-quote exp env)
  (list (syx 'special 'quote '())
        (syn-car (syn-cdr exp))))

(define (special-let/letrec rec? exp env)
  ;; (let(rec?) <bindings> <body> ...)
  ;;               ^ (<var> <exp>)*
  (let* ((bindings (syn-car (syn-cdr exp)))
         (body (implicit-begin (syn-cdr (syn-cdr exp))))
         (sc ((ss-env-scope-counter env)))
         (bindings^ (syn-map (lambda (binding)
                               (let* ((var (syn-car binding))
                                      (gen (gensym+ss-bind! env sc var))
                                      (exp (syn-car (syn-cdr binding)))
                                      (null (syn-cdr (syn-cdr binding))))
                                 (unless (null? null)
                                   (error 'BAD-BINDING))
                                 (list gen (if rec?
                                               (resolve-exp (annotate exp (set (list sc))) env)
                                               (resolve-exp exp env)))))
                             bindings)))
    (list (syx 'special (if rec? 'letrec 'let) '())
          bindings^
          (resolve-exp (annotate body (set (list sc))) env))))

(define (special-let exp env)
  (special-let/letrec #f exp env))

(define (special-letrec exp env)
  (special-let/letrec #t exp env))

(define (special-named-let exp env)
  ;;
  ;; (let <loop> ((<name> <exp>) ...) <body>)
  ;; --> (letrec ((<loop> (lambda (<name> ...) <body>))) (<loop> <exp> ...))
  ;;
  ;; (let ((<name> <exp>) ...) <body>)
  ;; --> let special form
  ;;
  (if (syx-id? (syn-car (syn-cdr exp)))
      ;; named-let
      (let* ((name (syn-car (syn-cdr exp)))
             (bindings (syn-car (syn-cdr (syn-cdr exp))))
             (body (syn-cdr (syn-cdr (syn-cdr exp))))
             (names (syn-map syn-car bindings))
             (exps (syn-map (o syn-car syn-cdr) bindings)))
        (special-letrec
         (list (syx 'id 'letrec '())
               (list (list name (list* (syx 'id 'lambda '())
                                       names
                                       body)))
               (list* name exps))
         env))
      ;; regular let special form
      (special-let exp env)))

(define (local/localrec-syntax exp env rec?)
  ;; TODO: The really important thing this needs to do is keep the definition local
  ;;       by creating a scope and such
  ;;
  ;; (local-syntax name expander body)
  ;;
  ;; in terms of scope sets,
  ;; we obviously have to create a new macro scope (this is sc/m-set)
  ;; 
  (let* ((name (syn-car (syn-cdr exp)))
         (sc ((ss-env-scope-counter env)))
         (m-set (set-insert sc (syx-scope-set name)))
         (expander (syn-car (syn-cdr (syn-cdr exp))))
         (body (syn-car (syn-cdr (syn-cdr (syn-cdr exp))))))
    (when rec?
      (ss-bind! env
                (syx-id name)
                m-set
                `(macro . ,(lambda (exp env) (error "cannot use a macro before it's definition" (syx-id name))))))
    (let* ((expander^ (if rec?
                          (resolve-exp (annotate expander (set (list sc))) env)
                          (resolve-exp expander env))))
      (ss-bind! env
                (syx-id name)
                m-set
                `(macro . ,(interpret-exp expander^ (ss-env-syntax-env env))))
      (resolve-exp (annotate body (set (list sc))) env))))

(define (local-syntax exp env) (local/localrec-syntax exp env #f))
(define (localrec-syntax exp env) (local/localrec-syntax exp env #t))

;;; primitive/built-in language macros
;;

(define (macro-let->lambda exp env)
  ;;
  ;; (let ((<name> <exp>) ...) <body>)
  ;;
  (let* ((bindings (syn-car (syn-cdr exp)))
	 (body (syn-cdr (syn-cdr exp)))
	 (names (syn-map syn-car bindings))
	 (exps (syn-map (o syn-car syn-cdr) bindings)))
    (list* (list* (syx 'id 'lambda '())
		  names
		  body)
	   exps)))

(define (macro-or exp env)
  ;; (OR) => #f
  ;; * (OR A . RST) => (IF A A (OR . RST))
  ;; (OR A . RST) => (LET ((TMP A)) (IF TMP TMP (OR . RST)))
  (if (null? (syn-cdr exp))
      (syx 'atomic #f '())
      (let ((a (syn-car (syn-cdr exp)))
	    (rst (syn-cdr (syn-cdr exp))))
	(list (syx 'id 'let '())
	      (list (list (syx 'id 'tmp '()) a))
	      (list (syx 'id 'if '())
		    (syx 'id 'tmp '())
		    (syx 'id 'tmp '())
		    (list* (syx 'id 'or '())
			   rst))))))

(define (macro-and exp env)
  ;; (AND) => #t
  ;; (AND x) => x
  ;; (AND a . rst) => (if a (AND . rst) #f)
  (if (null? (syn-cdr exp))
      (syx 'atomic #t '())
      (if (null? (syn-cdr (syn-cdr exp)))
	  (syn-car (syn-cdr exp))
	  (let ((a (syn-car (syn-cdr exp)))
		(rst (syn-cdr (syn-cdr exp))))
	    (list (syx 'id 'if '())
		  a
		  (list* (syx 'id 'and '())
			 rst)
		  (syx 'atomic #f '()))))))

;;;
;;

(define specials `((lambda . ,special-lambda)
		   (begin . ,special-begin)
		   (if . ,special-if)
		   (quote . ,special-quote)
		   (syntax-quote . ,special-syntax-quote)
                   (let . ,special-named-let)
                   (letrec . ,special-letrec)
                   (local-syntax . ,local-syntax)
                   (localrec-syntax . ,localrec-syntax)
                   ))
(define macros `(;;(or . ,macro-or)
		 ;;(and . ,macro-and)
                 ))

(define (create-env builtins)
  (let ((me-meta '((source . "builtin"))))
    (let ((env (ss-env (make-counter) empty-set (make-hash) (env builtins (list 'lambda 'begin 'if 'quote)))))
      (for-each (lambda (entry)
		  (ss-bind! env
			   (car entry)
			   empty-set
			   `(special . ,(cdr entry))))
		specials)
      (for-each (lambda (entry)
		  (ss-bind! env
			   (car entry)
			   empty-set
			   `(macro . ,(cdr entry))))
	        macros)
      (for-each (lambda (entry)
		  (ss-bind! env
			   (car entry)
			   empty-set
			   `(variable . ,(syx 'id (car entry) me-meta))))
		builtins)
      env)))
